home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops source / Module source / callsMod.txt < prev    next >
Text File  |  1998-05-30  |  9KB  |  377 lines
  1. room 750000 u<
  2. [IF]
  3.     cr .( not enough dic room to compile callsMod!) cr  ABORT
  4. [THEN]
  5.  
  6. false    constant    debug?
  7.  
  8. file  INPF
  9.  
  10. : #ALIGN4    \ ( n -- n' )
  11.     3 + $ fffffffc and  ;
  12.  
  13.  
  14. true -> case_in_names?
  15.  
  16. : macConstant
  17.     [ FALSE -> CASE_IN_NAMES? ]
  18.     >in @
  19.     defined?
  20.     IF        ['] inpf u>  IF  2drop  EXIT  THEN
  21.     ELSE    drop
  22.     THEN
  23.     >in !
  24.     constant
  25. ;
  26.  
  27.  
  28. : [IF]        drop  ;
  29. : [ELSE]    ;
  30. : [THEN]    ;
  31. : [ELIF]    drop  ;
  32.  
  33.  
  34. true -> case_in_names?
  35.  
  36. : macDefined?    DEFINED? NIP  ;
  37. : macStruct        MWORD DROP  ;
  38. : macUnion        MWORD DROP    ;
  39. : macField        DROP  MWORD DROP  ;
  40. : macFiller        2DROP  ;
  41. : macEnd-struct    2DROP  ;
  42. : macEnd-union    2DROP  ;
  43. : macSynonym    MWORD DROP  MWORD DROP  ;
  44.  
  45. : and            AND  ;
  46. : or            OR   ;
  47. : xor            XOR  ;
  48. : lshift        LSHIFT  ;
  49. : rshift        RSHIFT  ;
  50. : negate        NEGATE  ;
  51. : 'type            POSTPONE 'TYPE  ;  IMMEDIATE
  52.  
  53.  
  54. FALSE -> CASE_IN_NAMES?
  55.  
  56.  
  57. string temp
  58.  
  59. : READ_INLINE  { \ loc svd svCaseFlg -- }
  60.     case_in_names? -> svCaseFlg
  61.     false -> case_in_names?
  62.     clear: temp
  63.     BEGIN
  64.         >in @  src-len  >=
  65.         IF    svCaseFlg -> case_in_names?  EXIT
  66.         THEN
  67.         hex  mword number  decimal
  68.         pad w!  pad 2 add: temp
  69.     AGAIN  ;
  70.  
  71.  
  72. false    value    register_based?
  73. 0        value    ^hndlr
  74.  
  75. (*    For 68k parms, a parm or result might be in a register.  If so,
  76.     our parm info will have this format:
  77.  
  78.     byte 0        0
  79.     byte 1        $80 + reg number
  80.     byte 2        0
  81.     byte 3        length in bytes
  82.     
  83.     The reg numbers, as defined in MixedMode.h, are:
  84.     0    d0
  85.     1    d1
  86.     2    d2
  87.     3    d3
  88.     4    a0
  89.     5    a1
  90.     6    a2
  91.     7    a3
  92.     8    d4
  93.     9    d5
  94.     A    d6
  95.     B    d7
  96.     C    a4
  97.     D    a5
  98.     E    a6
  99.     
  100.     We have to return a 1-byte result, so we use this format:
  101.     
  102.     bit
  103.     0        1            means this is a register parm/result
  104.     1-3        length
  105.     4-7        reg code
  106.     
  107.     This byte is passed to Handlers which compiles the right register
  108.     pushes and/or pops.
  109. *)
  110.  
  111. : 68k_parm_adjust  { parm parm# parm? -- parm' }
  112.     parm -1 =
  113.     NIF
  114.         parm $ ffff0000 and
  115.         IF                        \ it's a register parm
  116.             true -> register_based?
  117.             $ D001  ^hndlr w!
  118.             parm dup 16 >>        \ reg code
  119.             swap 3 and            \ length
  120.             4 << or  EXIT
  121.         THEN
  122.     THEN
  123.     
  124.     parm?                        \ parm or result?
  125.     IF                            \ parm
  126.         register_based?
  127.         IF ." warning - non-reg parm in reg-based call  "
  128.             latest name> .id  cr
  129.         THEN
  130.         parm
  131. \        dup 1 and +            \ &&& don't round length any more
  132.     ELSE                        \ result
  133.         parm IF
  134.             register_based?
  135.             IF ." warning - non-reg result in reg-based call  "
  136.                 latest name> .id  cr
  137.             THEN
  138.         THEN
  139.         parm                        \ for results, we don't round so call
  140.     THEN                            \  windup gets done properly.
  141. ;
  142.  
  143.  
  144.     true -> case_in_names?
  145.  
  146. : macExtern
  147.  
  148.     [ FALSE -> CASE_IN_NAMES? ]
  149.  
  150. ( result-info parm-info #parms )
  151.         { \ #parms #cells #fparms #fres mask ^PPCinfo ^68kInfo -- }
  152.  
  153.     0 -> #cells  0 -> #fparms  false -> register_based?
  154.     0 -> #fres  0 -> mask
  155.  
  156. \    true -> case_in_names?
  157.     >in @
  158.     defined?
  159.     IF    ['] inpf u>
  160.         IF  drop                    \ drop >in - now TOS is # parms
  161.             -1 DO  2drop  LOOP        \ drop parm info, also result info
  162.             0 -> src-len            \ skip 68k inline code sequence
  163. \            false -> case_in_names?
  164.             EXIT
  165.         THEN
  166.     ELSE    drop
  167.     THEN
  168.  
  169.     >in !
  170.     create                        \ create the new dic entry (case sensitive)
  171. \    false -> case_in_names?
  172.     DP 2-  -> ^hndlr
  173.     $ D000  ^hndlr w!            \ dummy "handler code"
  174.     DP -> ^PPCinfo  0 ,  0 w,    \ leave space for PPC info
  175.     
  176. \ #parms
  177.     dup -> #parms  c,            \ store # parms for 68k
  178.     DP -> ^68kInfo
  179.     #parms
  180.     IF    pad #parms n,            \ reserve space for rest of 68k parm info
  181.  
  182.         #parms
  183.         FOR
  184.         \ #bytes in next PPC parm - convert to #cells and accumulate.  If
  185.         \  the $ 1000 bit is set, that means it's floating point - in that
  186.         \  case we count up the number of floating parms (these have to
  187.         \  be put in the FPRs for the call), and set the corresponding mask
  188.         \  bit so that the corresponding GPRs will get a dummy value.  This
  189.         \  calling convention is a bit crazy, but we're stuck with it.
  190.         \ Remember as the numbers have been pushed onto the stack, we're
  191.         \  going from the last parm backwards.  So i in this FOR loop gives
  192.         \  us the real parm# starting from zero.
  193.         
  194.             dup $ 1000 and
  195.             IF                \ it's floating
  196.                 1 ++> #fparms
  197.                 $ FFF and  dup 4 >
  198.                 IF        mask 2 >>  $ C000 or  -> mask    \ mask 2 dummy GPRs here
  199.                 ELSE    mask 1 >>  $ 8000 or  -> mask    \ single float - mask 1 GPR
  200.                 THEN
  201.             ELSE
  202.                 mask 1 >>  -> mask                    \ normal GPR cell - no mask bit
  203.             THEN
  204.             3 +  2 >>  ++> #cells
  205.  
  206.         \ 68k parm info
  207.             i true 68k_parm_adjust        \ check if reg-based and take care of it
  208.             ^68kInfo i + c!                \ store in right order in 68k info
  209.         NEXT
  210.     THEN
  211.  
  212.     #cells        ^PPCinfo c!            \ store # PPC parm cells at ^PPCinfo
  213.  
  214. \ ( #68k-res-bytes #PPC-res-bytes )
  215.  
  216.     dup $ 1000 and
  217.     IF                                \ PPC result is floating - so no integer result
  218.         1 -> #fres  drop 0
  219.     ELSE                            \ otherwise there's no floating result
  220.         3 +  2 >>
  221.     THEN        ^PPCinfo 1+ c!        \ store # PPC integer result cells at ^PPCinfo+1
  222.     #fparms        ^PPCinfo 2+ c!        \  and # PPC FP parms at ^PPCinfo+2
  223.     #fres        ^PPCinfo 3 + c!        \  and # PPC FP results at ^PPCinfo+3
  224.                                     \  (must be 0 or 1)
  225.     mask        ^PPCinfo 4+  w!
  226.  
  227.     0 false 68k_parm_adjust  c,        \ store 68k info.  We don't
  228.                                     \  round here since we have to know whether
  229.                                     \  and by how much to adjust by at the end
  230.                                     \  of the call.
  231.     align-dp
  232.     read_inline
  233.     reset: temp  len: temp  w,  all: temp  n,
  234.  
  235.     0 -> src-len        \ on the PPC we ignore the 68k inline code sequence
  236. ;
  237.  
  238.  
  239. : FIND_IN_CALLSMOD    \ ( s255 \ svCaseFlg -- cfa true | -- s255 false )
  240.     find: callsMod
  241. ;
  242.  
  243.  
  244. : myHeader
  245.     PPC? IF  ppc_header  ELSE  header  THEN  ;
  246.  
  247.  
  248. : KONST  { \ svCaseFlg -- konst }
  249.     case_in_names? -> svCaseFlg
  250.     true -> case_in_names?
  251.     ['] find_in_callsMod  -> extraFind
  252.     '
  253.     svCaseFlg -> case_in_names?
  254.     0 -> extraFind
  255.     dup 2- w@x  -4 <>  abort" not a konst!"
  256.     @  postpone lit
  257. ;        immediate
  258.  
  259.  
  260. : $>KONST  { addr len \ svCaseFlg -- konst }
  261.     case_in_names? -> svCaseFlg
  262.     true -> case_in_names?
  263.     ['] find_in_callsMod  -> extraFind
  264.     addr len sFind
  265.     svCaseFlg -> case_in_names?
  266.     0 -> extraFind
  267.     NIF  abort" konst not defined"  THEN
  268.     dup 2- w@x  -4 <>  abort" not a konst!"
  269.     @
  270. ;
  271.  
  272.  
  273. (*
  274. syscall bloggs  defines "bloggs" as an system call (from the InterfaceLib
  275. library).
  276.  
  277. In a definition we just put "bloggs" and it compiles a call to bloggs.  We
  278. resolve the symbol via a FindSymbol call, the first time it's called (see
  279. get_transfer_vector in Setup - a call is compiled to there as part of the
  280. external call sequence, compiled by call_extern in cg5).
  281. *)
  282.  
  283. : SYSCALL  { \    svCaseFlg sv-in addr #parms
  284.                 #parm_cells #fparms #res_cells #fres mask
  285.                 len ^len-byte  name_len -- }
  286.     ?exec
  287.     >in @  -> sv-in
  288.  
  289. \ first, is it actually a known call?
  290.  
  291.     case_in_names? -> svCaseFlg
  292.     true -> case_in_names?
  293.     ['] find_in_callsMod  -> extraFind
  294.     mword find NIF  150 die  THEN        \ "can't find call for this name"
  295.     0 -> extraFind  svCaseFlg -> case_in_names?
  296.     -> addr
  297.     addr 2- w@
  298.     dup 1 and  -> register_based?
  299.     -2 and  $ D000 <>  abort" not a call!"
  300.  
  301. \ now, if we've already defined it as a sysCall, and it's currently
  302. \  FINDable, we don't need to define it again here.
  303.  
  304.     sv-in  >in !
  305.     defined?
  306.     IF    2- w@x
  307.         CASE[ -120 ], [ -122 ]=>    PPC? 0EXIT
  308.             [ $ BF01 ]=>            PPC? ?EXIT
  309.             DEFAULT=>  drop
  310.         ]CASE
  311.     ELSE
  312.         drop
  313.     THEN
  314.  
  315.     sv-in  >in !
  316.  
  317.     PPC?
  318.     IF    myHeader  $ BF01  codeW,        \  $BF01 = handler code for sysCall
  319.  
  320.         addr c@        -> #parm_cells
  321.         addr 1+ c@    -> #res_cells
  322.         addr 2+ c@    -> #fparms
  323.         addr 3 + c@    -> #fres
  324.         addr 4+  w@ -> mask
  325.  
  326.         #parm_cells codeC,        \ 1 byte # parm cells
  327.         #res_cells codeC,        \ 1 byte # result cells
  328.         #fparms  codeC,            \ 1 byte # FP parms (in FPRs)
  329.         #fres  codeC,            \ 1 byte # FP results (in FPRs)
  330.         mask  codeW,
  331.  
  332.         DP  nilP ,                \ put nilP in data area - means not resolved yet
  333.         " relocCode,x" evaluate            \ not defined till cg6
  334.         0 code,                            \ for EXTERNs, lib addr goes here.  For SYSCALL,
  335.                                         \  we put zero.  (This is different to 68k)
  336.         addr >name n>count dup -> name_len
  337.         CDP place
  338.         name_len 2+ #align4  ++> CDP
  339.     ELSE
  340.         header
  341.         register_based?  IF  -122  ELSE  -120  THEN
  342.         w,                        \ sysCall_h handler for 68k
  343.         6 ++> addr                \ look at 68k parm info
  344.         addr c@  -> #parms
  345.         DP -> ^len-byte  0 c,    \ total length of call info will go here
  346.         #parms c,
  347.         1 ++> addr
  348.         #parms 1+ FOR            \ add 1 since we're including the result byte
  349.             addr c@  c,  1 ++> addr
  350.         NEXT
  351.         addr 1 and  ++> addr
  352.         1 or> DP                \ put DP to odd bdry since we'll be omitting
  353.                                 \  the length byte
  354.         addr length                \ ( addr len ) for inline code
  355.         dup NIF  152 die  THEN    \ "not a real call" - since no inline code
  356.         n,                        \ move inline code over
  357.         DP ^len-byte - 1-
  358.         ^len-byte c!            \ and store length of call info (excluding length byte)
  359.     THEN
  360. ;
  361.  
  362.  
  363. new: temp
  364.  
  365. cr
  366. cr .( Note: loading this next file will take quite a while.)
  367. cr .( A coffee break would be a good idea.)  cr
  368.  
  369. true -> case_in_names?
  370. // xcalls
  371. FALSE -> CASE_IN_NAMES?
  372.  
  373. release: temp
  374.  
  375. cr .( Dic room at end of compiling callsMod: )  room . cr
  376.  
  377.